home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 January, February, March & April / Chip-Cover-CD-2007-02.iso / Pakiet bezpieczenstwa / mini Pentoo LiveCD 2006.1 / mpentoo-2006.1.iso / livecd.squashfs / usr / lib / perl5 / 5.8.7 / base.pm < prev    next >
Text File  |  2006-04-25  |  5KB  |  227 lines
  1. package base;
  2.  
  3. use strict 'vars';
  4. use vars qw($VERSION);
  5. $VERSION = '2.07';
  6.  
  7. # constant.pm is slow
  8. sub SUCCESS () { 1 }
  9.  
  10. sub PUBLIC     () { 2**0  }
  11. sub PRIVATE    () { 2**1  }
  12. sub INHERITED  () { 2**2  }
  13. sub PROTECTED  () { 2**3  }
  14.  
  15.  
  16. my $Fattr = \%fields::attr;
  17.  
  18. sub has_fields {
  19.     my($base) = shift;
  20.     my $fglob = ${"$base\::"}{FIELDS};
  21.     return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
  22. }
  23.  
  24. sub has_version {
  25.     my($base) = shift;
  26.     my $vglob = ${$base.'::'}{VERSION};
  27.     return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
  28. }
  29.  
  30. sub has_attr {
  31.     my($proto) = shift;
  32.     my($class) = ref $proto || $proto;
  33.     return exists $Fattr->{$class};
  34. }
  35.  
  36. sub get_attr {
  37.     $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]};
  38.     return $Fattr->{$_[0]};
  39. }
  40.  
  41. if ($] < 5.009) {
  42.     *get_fields = sub {
  43.     # Shut up a possible typo warning.
  44.     () = \%{$_[0].'::FIELDS'};
  45.     my $f = \%{$_[0].'::FIELDS'};
  46.  
  47.     # should be centralized in fields? perhaps
  48.     # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' }
  49.     # is used here anyway, it doesn't matter.
  50.     bless $f, 'pseudohash' if (ref($f) ne 'pseudohash');
  51.  
  52.     return $f;
  53.     }
  54. }
  55. else {
  56.     *get_fields = sub {
  57.     # Shut up a possible typo warning.
  58.     () = \%{$_[0].'::FIELDS'};
  59.     return \%{$_[0].'::FIELDS'};
  60.     }
  61. }
  62.  
  63. sub import {
  64.     my $class = shift;
  65.  
  66.     return SUCCESS unless @_;
  67.  
  68.     # List of base classes from which we will inherit %FIELDS.
  69.     my $fields_base;
  70.  
  71.     my $inheritor = caller(0);
  72.  
  73.     foreach my $base (@_) {
  74.         next if $inheritor->isa($base);
  75.  
  76.         if (has_version($base)) {
  77.         ${$base.'::VERSION'} = '-1, set by base.pm' 
  78.           unless defined ${$base.'::VERSION'};
  79.         }
  80.         else {
  81.             local $SIG{__DIE__};
  82.             eval "require $base";
  83.             # Only ignore "Can't locate" errors from our eval require.
  84.             # Other fatal errors (syntax etc) must be reported.
  85.             die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
  86.             unless (%{"$base\::"}) {
  87.                 require Carp;
  88.                 Carp::croak(<<ERROR);
  89. Base class package "$base" is empty.
  90.     (Perhaps you need to 'use' the module which defines that package first.)
  91. ERROR
  92.  
  93.             }
  94.             ${$base.'::VERSION'} = "-1, set by base.pm"
  95.               unless defined ${$base.'::VERSION'};
  96.         }
  97.         push @{"$inheritor\::ISA"}, $base;
  98.  
  99.         if ( has_fields($base) || has_attr($base) ) {
  100.         # No multiple fields inheritence *suck*
  101.         if ($fields_base) {
  102.         require Carp;
  103.         Carp::croak("Can't multiply inherit %FIELDS");
  104.         } else {
  105.         $fields_base = $base;
  106.         }
  107.         }
  108.     }
  109.  
  110.     if( defined $fields_base ) {
  111.         inherit_fields($inheritor, $fields_base);
  112.     }
  113. }
  114.  
  115.  
  116. sub inherit_fields {
  117.     my($derived, $base) = @_;
  118.  
  119.     return SUCCESS unless $base;
  120.  
  121.     my $battr = get_attr($base);
  122.     my $dattr = get_attr($derived);
  123.     my $dfields = get_fields($derived);
  124.     my $bfields = get_fields($base);
  125.  
  126.     $dattr->[0] = @$battr;
  127.  
  128.     if( keys %$dfields ) {
  129.         warn "$derived is inheriting from $base but already has its own ".
  130.              "fields!\n".
  131.              "This will cause problems.\n".
  132.              "Be sure you use base BEFORE declaring fields\n";
  133.     }
  134.  
  135.     # Iterate through the base's fields adding all the non-private
  136.     # ones to the derived class.  Hang on to the original attribute
  137.     # (Public, Private, etc...) and add Inherited.
  138.     # This is all too complicated to do efficiently with add_fields().
  139.     while (my($k,$v) = each %$bfields) {
  140.         my $fno;
  141.     if ($fno = $dfields->{$k} and $fno != $v) {
  142.         require Carp;
  143.         Carp::croak ("Inherited %FIELDS can't override existing %FIELDS");
  144.     }
  145.  
  146.         if( $battr->[$v] & PRIVATE ) {
  147.             $dattr->[$v] = PRIVATE | INHERITED;
  148.         }
  149.         else {
  150.             $dattr->[$v] = INHERITED | $battr->[$v];
  151.             $dfields->{$k} = $v;
  152.         }
  153.     }
  154.  
  155.     foreach my $idx (1..$#{$battr}) {
  156.     next if defined $dattr->[$idx];
  157.     $dattr->[$idx] = $battr->[$idx] & INHERITED;
  158.     }
  159. }
  160.  
  161.  
  162. 1;
  163.  
  164. __END__
  165.  
  166. =head1 NAME
  167.  
  168. base - Establish IS-A relationship with base classes at compile time
  169.  
  170. =head1 SYNOPSIS
  171.  
  172.     package Baz;
  173.     use base qw(Foo Bar);
  174.  
  175. =head1 DESCRIPTION
  176.  
  177. Allows you to both load one or more modules, while setting up inheritance from
  178. those modules at the same time.  Roughly similar in effect to
  179.  
  180.     package Baz;
  181.     BEGIN {
  182.         require Foo;
  183.         require Bar;
  184.         push @ISA, qw(Foo Bar);
  185.     }
  186.  
  187. If any of the listed modules are not loaded yet, I<base> silently attempts to
  188. C<require> them (and silently continues if the C<require> failed).  Whether to
  189. C<require> a base class module is determined by the absence of a global variable
  190. $VERSION in the base package.  If $VERSION is not detected even after loading
  191. it, <base> will define $VERSION in the base package, setting it to the string
  192. C<-1, set by base.pm>.
  193.  
  194. Will also initialize the fields if one of the base classes has it.
  195. Multiple inheritence of fields is B<NOT> supported, if two or more
  196. base classes each have inheritable fields the 'base' pragma will
  197. croak.  See L<fields>, L<public> and L<protected> for a description of
  198. this feature.
  199.  
  200. =head1 DIAGNOSTICS
  201.  
  202. =over 4
  203.  
  204. =item Base class package "%s" is empty.
  205.  
  206. base.pm was unable to require the base package, because it was not
  207. found in your path.
  208.  
  209. =back
  210.  
  211. =head1 HISTORY
  212.  
  213. This module was introduced with Perl 5.004_04.
  214.  
  215.  
  216. =head1 CAVEATS
  217.  
  218. Due to the limitations of the implementation, you must use
  219. base I<before> you declare any of your own fields.
  220.  
  221.  
  222. =head1 SEE ALSO
  223.  
  224. L<fields>
  225.  
  226. =cut
  227.